home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / innum.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  109 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Inexact numbers as mere shells surrounding exact numbers.
  5.  
  6. (define-extended-number-type :innum (:inexact)
  7.   (make-innum exact)
  8.   innum?
  9.   (exact innum-exact))
  10.  
  11. (define-method &exact?  ((n :innum)) #f)
  12.  
  13. (define-method &complex?  ((n :innum)) (complex?  (innum-exact n)))
  14. (define-method &real?     ((n :innum)) (real?      (innum-exact n)))
  15. (define-method &rational? ((n :innum)) (rational? (innum-exact n)))
  16. (define-method &integer?  ((n :innum)) (integer?  (innum-exact n)))
  17.  
  18. (define-method &exact->inexact (n)
  19.   (if (innum? n)
  20.       (next-method)
  21.       (make-innum n)))
  22.  
  23. (define-method &inexact->exact ((n :innum)) (innum-exact n))
  24.  
  25. (define (inexactify n)
  26.   (if (exact? n)
  27.       (exact->inexact n)
  28.       n))
  29.  
  30. (define (define-innum-method mtable proc)
  31.   (define-method mtable ((m :innum) (n :number))
  32.     (inexactify (proc (innum-exact m) n)))
  33.   (define-method mtable ((m :number) (n :innum))
  34.     (inexactify (proc m (innum-exact n)))))
  35.  
  36. (define-innum-method &+ +)
  37. (define-innum-method &- -)
  38. (define-innum-method &* *)
  39. (define-innum-method &/ /)
  40. (define-innum-method "ient quotient)
  41. (define-innum-method &remainder remainder)
  42.  
  43. (define (define-innum-comparison mtable proc)
  44.   (define-method mtable ((m :innum) (n :number))
  45.     (proc (innum-exact m) n))
  46.   (define-method mtable ((m :number) (n :innum))
  47.     (proc m (innum-exact n))))
  48.  
  49. (define-innum-comparison &= =)
  50. (define-innum-comparison &< <)
  51.  
  52. (define-method &numerator   ((n :innum))
  53.   (inexactify (numerator (innum-exact n))))
  54.  
  55. (define-method &denominator ((n :innum))
  56.   (inexactify (denominator (innum-exact n))))
  57.  
  58. (define-method &floor ((n :innum))
  59.   (inexactify (floor (innum-exact n))))
  60.  
  61. (define-method &number->string ((i :innum) radix)
  62.   (let ((n (innum-exact i)))
  63.     (cond ((integer? n)
  64.        (string-append (number->string n radix) "."))
  65.       ((rational? n)
  66.        (let ((q (denominator n)))
  67.          (if (= radix 10)
  68.          (let ((foo (decimable? q)))
  69.            (if foo
  70.                (decimal-representation (numerator n) q foo)
  71.                (string-append "#i" (number->string n radix))))
  72.          (string-append "#i" (number->string n radix)))))
  73.       (else
  74.        (string-append "#i" (number->string n radix))))))
  75.  
  76. ; The Scheme report obligates us to print inexact rationals using
  77. ; decimal points whenever this can be done without losing precision.
  78.  
  79. (define (decimal-representation p q foo)
  80.   (let ((kludge (number->string (* (car foo) (abs (remainder p q)))
  81.                 10)))
  82.     (string-append (if (< p 0) "-" "")
  83.            (number->string (quotient (abs p) q) 10)
  84.            "."
  85.            (string-append (do ((i (- (cdr foo) (string-length kludge))
  86.                       (- i 1))
  87.                        (l '() (cons #\0 l)))
  88.                       ((<= i 0) (list->string l)))
  89.                   kludge))))
  90.  
  91. (define (ratio-string p q radix)
  92.   (string-append (number->string p radix)
  93.          "/"
  94.          (number->string q radix)))
  95.  
  96. ; (decimable? n) => non-#f iff n is a product of 2's and 5's.
  97. ; The value returned is (k . i) such that 10^i divides n * k.
  98.  
  99. (define (decimable? n)
  100.   (let loop ((n n) (d 1) (i 0))
  101.     (if (= n 1)
  102.     (cons d i)
  103.     (let ((q (quotient n 10))
  104.           (r (remainder n 10)))
  105.       (cond ((= r 0) (loop q d (+ i 1)))
  106.         ((= r 5) (loop (quotient n 5) (* d 2) (+ i 1)))
  107.         ((even? r) (loop (quotient n 2) (* d 5) (+ i 1)))
  108.         (else #f))))))
  109.